VERSION 5.00
Object = "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}#1.1#0"; "SHDOCVW.dll"
Object = "{48E59290-9880-11CF-9754-00AA00C00908}#1.0#0"; "MSINET.OCX"
Begin VB.Form frmWebUrlSpider 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Website guide spider"
   ClientHeight    =   6495
   ClientLeft      =   45
   ClientTop       =   435
   ClientWidth     =   14775
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MDIChild        =   -1  'True
   MinButton       =   0   'False
   ScaleHeight     =   6495
   ScaleWidth      =   14775
   Begin SHDocVwCtl.WebBrowser WebBrowser1 
      Height          =   5775
      Left            =   8040
      TabIndex        =   13
      Top             =   360
      Width           =   6495
      ExtentX         =   11456
      ExtentY         =   10186
      ViewMode        =   0
      Offline         =   0
      Silent          =   1
      RegisterAsBrowser=   0
      RegisterAsDropTarget=   1
      AutoArrange     =   0   'False
      NoClientEdge    =   0   'False
      AlignLeft       =   0   'False
      NoWebView       =   0   'False
      HideFileNames   =   0   'False
      SingleClick     =   0   'False
      SingleSelection =   0   'False
      NoFolders       =   0   'False
      Transparent     =   0   'False
      ViewID          =   "{0057D0E0-3573-11CF-AE69-08002B2E1262}"
      Location        =   "http:///"
   End
   Begin VB.CommandButton cmdExit 
      Caption         =   "Exit"
      Height          =   375
      Left            =   240
      TabIndex        =   12
      Top             =   4440
      Width           =   4335
   End
   Begin VB.CommandButton Command5 
      Caption         =   "Operator - Helper3"
      Height          =   615
      Left            =   3360
      TabIndex        =   9
      Top             =   3720
      Width           =   1335
   End
   Begin VB.CommandButton Command4 
      Caption         =   "Operator - Helper2"
      Height          =   615
      Left            =   1680
      TabIndex        =   8
      Top             =   3720
      Width           =   1335
   End
   Begin VB.CommandButton Command3 
      Caption         =   "Operator - Helper1"
      Height          =   615
      Left            =   120
      TabIndex        =   7
      Top             =   3720
      Width           =   1335
   End
   Begin VB.CommandButton Command2 
      Caption         =   "Operator - Cavin"
      Height          =   615
      Left            =   3360
      TabIndex        =   6
      Top             =   3000
      Width           =   1335
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Operator - Xiang"
      Height          =   615
      Left            =   1680
      TabIndex        =   5
      Top             =   3000
      Width           =   1335
   End
   Begin VB.CommandButton cmdO1 
      Caption         =   "Operator - Liang"
      Height          =   615
      Left            =   120
      TabIndex        =   4
      Top             =   3000
      Width           =   1335
   End
   Begin InetCtlsObjects.Inet Inet 
      Left            =   0
      Top             =   0
      _ExtentX        =   1005
      _ExtentY        =   1005
      _Version        =   393216
   End
   Begin VB.Line Line1 
      X1              =   7680
      X2              =   7680
      Y1              =   240
      Y2              =   4440
   End
   Begin VB.Label lblStatus 
      Height          =   615
      Left            =   600
      TabIndex        =   11
      Top             =   240
      Width           =   6615
   End
   Begin VB.Label Label3 
      Caption         =   $"frmWebUrlSpider.frx":0000
      Height          =   1695
      Left            =   4920
      TabIndex        =   10
      Top             =   3000
      Width           =   2535
   End
   Begin VB.Label lblWeb 
      Height          =   855
      Left            =   2640
      TabIndex        =   3
      Top             =   1920
      Width           =   4455
   End
   Begin VB.Label Label2 
      Caption         =   "Name of Website:"
      Height          =   615
      Left            =   480
      TabIndex        =   2
      Top             =   2040
      Width           =   1455
   End
   Begin VB.Label lblIndex 
      Height          =   855
      Left            =   2640
      TabIndex        =   1
      Top             =   1200
      Width           =   4455
   End
   Begin VB.Label Label1 
      Caption         =   "Index of websites:"
      Height          =   615
      Left            =   480
      TabIndex        =   0
      Top             =   1320
      Width           =   1455
   End
End
Attribute VB_Name = "frmWebUrlSpider"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim rsInsert As New ADODB.Recordset

Private Sub CloseRecordSet(ByRef rs As ADODB.Recordset)
On Error GoTo NoErr
        rs.Close
NoErr:
End Sub


Private Sub cmdExit_Click()
    End
End Sub

Private Sub cmdO1_Click()
    Dim sql, txtWeb, txtTitle, txtDes, txtKeywords, sqlInsert As String
    ' Liang will download first 150,000 data
    
    'get weburl from database
    Call Cn2Oversea(cn)
  
 '  On Error GoTo Err1:
  '  sql = "SET NAMES gbk"
 '   Call CloseRecordSet(rs)
 '   OperateDatabase rs, cn, sql
'Err1:
 '   MsgBox "2"
    sql = "SELECT * from `alphaW` WHERE `Done`=0 limit 0, 10000"
    Call CloseRecordSet(rs)
    OperateDatabase rs, cn, sql
  '  MsgBox "3"
    While Not rs.EOF
    'general all data
        WebBrowser1.Navigate "http://www." & rs.Fields(1).value
        While WebBrowser1.Busy Or (WebBrowser1.readyState <> READYSTATE_COMPLETE)
            DoEvents
        Wend
        'txtWeb = GetWebHTML("http://www." & rs.Fields(1).value)
        'txtWeb = GetWebHTML("http://www.groupon.com")
        txtTitle = ""
        txtDes = ""
        txtKeywords = ""
        For i = 0 To WebBrowser1.Document.All.length - 1
            sTag = WebBrowser1.Document.All(i).tagName
            sInnerTxt = WebBrowser1.Document.All(i).innertext
            
            If LCase(sTag) = "title" Then
                txtTitle = sInnerTxt
            End If
            If LCase(sTag) = "meta" Then
                sName = WebBrowser1.Document.All(i).NAME
                If LCase(sName) = "keywords" Then
                    txtKeywords = WebBrowser1.Document.All(i).content
                End If
                If LCase(sName) = "description" Then
                    txtDes = WebBrowser1.Document.All(i).content
                End If
            End If
        Next
        
        'txtTitle = GetPageTitle(txtWeb)
        'txtDes = GetPageDescription(txtWeb)
        'txtKeywords = GetPageKeywords(txtWeb)
        If txtKeywords = "" Then
            If txtDes <> "" Then
                txtKeywords = txtDes
            Else
                txtKeywords = txtTitle
            End If
        End If
        
        'show index
        lblIndex.Caption = rs.Fields(0).value
        'show name
        lblWeb.Caption = txtTitle
        DoEvents
        'save it to database and update the status
        sqlInsert = "UPDATE `alphaw` SET `Title`='" & (AddSlashes(txtTitle)) & "', `Keywords`='" & (AddSlashes(txtKeywords)) & "', `Description`='" & (AddSlashes(txtDes)) & "', Done=1 WHERE ID=" & rs.Fields(0).value
        Call CloseRecordSet(rsInsert)
        OperateDatabase rsInsert, cn, sqlInsert
        
        
        rs.MoveNext
    Wend
    
End Sub



Private Sub Form_Load()
    lblStatus.Caption = "Please press the operator button!"
    lblIndex.Caption = "0"
    lblWeb.Caption = "Waiting"
End Sub



Function GetPageTitle(ByVal strCode As String) As String
  Dim strTemp As String, i As Long, j As Long
  If strCode = "" Then
    GetPageTitle = ""
    Exit Function
  End If
  i = InStr(1, LCase(strCode), "<title>") + 7
  If i <> 0 Then
    j = InStr(i, LCase(strCode), "</title>")
    If j <> 0 Then
    strTemp = Mid(strCode, i, j - i)
    GetPageTitle = strTemp
    Else
    GetPageTitle = ""
    End If
  Else
    GetPageTitle = ""
  End If
End Function

Function GetPageDescription(ByVal strCode As String) As String
    '<meta name="description" content="This is a description ..">
    Dim strTemp As String
    Dim i As Long
    If strCode = "" Then
    GetPageDescription = ""
    Exit Function
  End If
  
    i = 1
    GetPageDescription = "No description!"
    While (i > 0)
        i = InStr(i, LCase(strCode), "<meta")
        If i = 0 Then
            GetPageDescription = ""
            Exit Function
        End If
        strTemp = GetOneLine(i, strCode)
        i = i + Len(strTemp)
        strTemp = GetDescription(strTemp)
        If strTemp <> "" Then
            GetPageDescription = strTemp
            Exit Function
        End If
    Wend
End Function

Private Function GetPageKeywords(ByVal strCode As String)
'<meta name="description" content="This is a description ..">
    Dim strTemp As String
    Dim i As Long
    If strCode = "" Then
    GetPageKeywords = ""
    Exit Function
  End If
  
    i = 1
    GetPageKeywords = ""
    While (i > 0)
        i = InStr(i, LCase(strCode), "<meta")
        If i = 0 Then
            GetPageKeywords = ""
            Exit Function
        End If
        strTemp = GetOneLine(i, strCode)
        i = i + Len(strTemp)
        strTemp = GetKeywords(strTemp)
        If strTemp <> "" Then
            GetPageKeywords = strTemp
            Exit Function
        End If
    Wend
End Function

Private Function GetDescription(ByVal strTemp As String) As String
    Dim i, j As Long, strDes As String
    i = InStr(1, LCase(strTemp), "description") + 15
    If i <> 15 Then
        'confirmed this is a description, and look for the pos of content
        i = InStr(1, LCase(strTemp), "content") + 1
        
        i = InStr(i, strTemp, Chr(34)) + 1
         j = InStr(i, strTemp, Chr(34))
        If j <= 0 Then
            j = InStr(i, strTemp, Chr(47)) - 1
            If j <= 0 Then
                j = InStr(i, strTemp, Chr(62)) - 1
            End If
        End If
        GetDescription = Mid(strTemp, i, j - i + 1)
    Else
        GetDescription = ""
    End If
End Function

Private Function GetKeywords(ByVal strTemp As String) As String
    Dim i, j As Long, strDes As String
    i = InStr(1, LCase(strTemp), "keywords") + 10
    If i <> 10 Then
       'confirmed this is a description, and look for the pos of content
        i = InStr(1, LCase(strTemp), "content") + 1
        
        i = InStr(i, strTemp, Chr(34)) + 1
        j = InStr(i, strTemp, Chr(34))
        If j <= 0 Then
            j = InStr(i, strTemp, Chr(47)) - 1
            If j <= 0 Then
                j = InStr(i, strTemp, Chr(62)) - 1
            End If
        End If
        GetKeywords = Mid(strTemp, i, j - i + 1)
    Else
        GetKeywords = ""
    End If
End Function

Private Function GetOneLine(ByVal i As Long, ByVal strCode As String) As String
    Dim iRet As Long
    iRet = InStr(i, strCode, Chr(62))
    If iRet <> 0 Then
        GetOneLine = Mid(strCode, i, iRet - i + 1)
    Else
        GetOneLine = ""
    End If
End Function
Function GetPageDescription1(ByVal strCode As String) As String
    'Dim re As New RegExp
    'Dim mh As Match
    'Dim mhs As MatchCollection
    
    '<meta name="description" content="This is a description ..">
    're.Pattern = "(?<=content=" & Chr(34) & ")[^" & Chr(34) & "]*(?:(?<=(.*description.*)|(?=(.*description.*))))"
    'Debug.Print re.Pattern
    'Set mhs = re.Execute(strCode)
    'Set mh = mhs(0)
    
    'Debug.Print mh.value
    'GetPageDescription = mh.value
End Function


